home *** CD-ROM | disk | FTP | other *** search
/ Hottest 6 / Hottest 6 (1996)(PDSoft)[!].iso / software / programming / pascal / hspascal_baseunit.lha / New / Base.PAS next >
Pascal/Delphi Source File  |  1993-03-06  |  7KB  |  243 lines
  1. unit Base;
  2.  
  3. interface
  4.  
  5. { *    This unit provides a simple cleans-up-after-itself interface to the
  6.     Graphics and Intuition libraries.  USEing this unit will automatically
  7.     open the Intuition and Graphics libraries, which will be closed when
  8.     your program ends.
  9.     
  10.     Also provided are two functions to open simple screens and windows.
  11.     These will also be closed when your program ends, regardless.
  12. }
  13.  
  14. uses
  15.     Exec, Intuition, Graphics;
  16. var
  17.     okBase    : boolean; { TRUE if everything initializes well }
  18.  
  19. {--- Available functions ---}
  20. function NewScreen(wide,high,deep,view: word;
  21.                     title: string;custom: boolean): pScreen;
  22.  
  23. function NewWindow(left,top,wide,high: word;
  24.                     f_idcmp,f_settings: longint;
  25.                     wmin,hmin,wmax,hmax: word;
  26.                     wtitle: string;wscreen: pScreen): pWindow;
  27.  
  28. implementation
  29.  
  30. const
  31.     BASE_SCREEN = 1;    { Screen stored in list ID }
  32.     BASE_WINDOW = 2;    { Window stored in list ID }
  33.     MAX_BASE_LIST = 20;    { Max. number of screens+windows that
  34.                             would be automatically taken care of }
  35. type
  36.     base_list = record { Record of all opened screens and windows }
  37.         case kind : byte of
  38.             BASE_SCREEN : (pscr : pScreen);
  39.             BASE_WINDOW : (pwin : pWindow)
  40.     end;
  41. var
  42.     ExitSave    : pointer;    { Temporary storage for the exit procedure }
  43.     BaseList    : array[1..MAX_BASE_LIST] of base_list;    { Auto. list }
  44.     topBaseList    : byte;        { How many items in the auto. list }
  45. {----------------------------------------------------------}
  46. procedure CloseBaseList;
  47.  
  48. { *    Closes the last screen or window that was opened }
  49.  
  50. var
  51.     test    : boolean;
  52. begin
  53.     if topBaseList>0 then    { Any opened with NewWindow or NewScreen? }
  54.     begin
  55.         with BaseList[topBaseList] do    { If so, close the last one }
  56.             case kind of
  57.                 BASE_WINDOW :
  58.                     CloseWindow(pwin);
  59.                 BASE_SCREEN :
  60.                     test := CloseScreen(pscr)
  61.             end;
  62.         dec(topBaseList)    { Decrease the total number of them }
  63.     end
  64. end;
  65. {----------------------------------------------------------}
  66. {$F+}
  67. procedure CloseBase;
  68.  
  69. { * This is put in the list of procedures to go through when
  70.     the program exits.  It closes all screens and windows
  71.     opened with NewWindow or NewScreen, and closes the graphics
  72.     and intuition libraries as well
  73. }
  74.  
  75. begin
  76.     ExitProc := ExitSave;    { Restore exit pointer to original }
  77.     while topBaseList>0 do    { Close all New.. Windows and Screens }
  78.         CloseBaseList;
  79.     if GfxBase<>nil then    { Close graphics library if opened }
  80.         CloseLibrary(pLibrary(GfxBase));
  81.     if IntuitionBase<>nil then    { Close intuition library if opened }
  82.         CloseLibrary(pLibrary(IntuitionBase))
  83. end;
  84. {----------------------------------------------------------}
  85. function NewScreen(wide,high,deep,view: word;
  86.                     title: string;custom: boolean): pScreen;
  87.  
  88. { * A quick function to open a screen of dimensions WIDExHIGH,
  89.     with DEEP number of planes. 
  90.     VIEW is the viewmodes (HIRES, LACE, etc.)
  91.     TITLE is the title for the screen bar.
  92.     CUSTOM is TRUE for a custom screen, FALSE for a workbench-
  93.         type of screen.
  94.     Returns a pointer to the screen that was opened, or NIL
  95.         if the operation was not successful
  96. }
  97.  
  98. var
  99.     new_scr    : tNewScreen;
  100.     act_scr : pScreen;                    
  101. begin
  102.     if topBaseList>=MAX_BASE_LIST then
  103.     begin
  104.         NewScreen := nil;
  105.         exit
  106.     end;
  107.     with new_scr do
  108.     begin
  109.         LeftEdge := 0;
  110.         TopEdge := 0;
  111.         Width := wide;
  112.         Height := high;
  113.         Depth := deep;
  114.         DetailPen := 0;
  115.         BlockPen := 1;
  116.         ViewModes := view;
  117.         if custom then
  118.             Type_ := CUSTOMSCREEN
  119.         else
  120.             Type_ := WBENCHSCREEN;
  121.         Font := nil;
  122.         if title='' then
  123.             DefaultTitle := nil
  124.         else
  125.         begin
  126.             title := title+#0;    { Make it a zero-terminated string }
  127.             DefaultTitle := @title[1]
  128.         end;
  129.         Gadgets := nil;
  130.         CustomBitMap := nil
  131.     end;
  132.     act_scr := OpenScreen(@new_scr);
  133.     if act_scr<>nil then    { Did it open okay? }
  134.     begin
  135.         inc(topBaseList);    { Add it to the auto. list }
  136.         with BaseList[topBaseList] do
  137.         begin
  138.             kind := BASE_SCREEN;
  139.             pscr := act_scr
  140.         end;
  141.         NewScreen := act_scr
  142.     end
  143.     else
  144.         NewScreen := nil
  145. end;
  146. {----------------------------------------------------------}
  147. function NewWindow(left,top,wide,high: word;
  148.                     f_idcmp,f_settings: longint;
  149.                     wmin,hmin,wmax,hmax: word;
  150.                     wtitle: string;wscreen: pScreen): pWindow;
  151.  
  152. { *    A quick function to open a window, upper left at LEFT,TOP,
  153.     with dimensions WIDExHIGH.
  154.     F_IDCMP are the IDCMP flags to look for (CLOSEWINDOW_,
  155.         VANILLAKEY, etc.)
  156.     F_SETTINGS are the display flags to set (WINDOWCLOSE,
  157.         WINDOWDRAG, etc.)
  158.     WMIN,HMIN are the minimum dimensions of the window to allow.*
  159.     WMAX,HMAX are the maximum dimensions of the window to allow.*
  160.     (*Set all to zero if the window is not resizeable, otherwise
  161.       the window will be set to be resizeable)
  162.     WTITLE is the title of the window.
  163.     WSCREEN is a pointer to the screen to put it on, NIL for the
  164.         Workbench screen.
  165.     Returns a pointer to the opened window, or NIL if the
  166.         operation was not successful
  167. }
  168.  
  169. var
  170.     new_win        : tNewWindow;
  171.     act_win        : pWindow;
  172. begin
  173.     if topBaseList>=MAX_BASE_LIST then { Too many already? }
  174.     begin
  175.         NewWindow := nil;
  176.         exit
  177.     end;
  178.     with new_win do
  179.     begin
  180.         LeftEdge := left;
  181.         TopEdge := top;
  182.         Width := wide;
  183.         Height := high;
  184.         DetailPen := -1;
  185.         BlockPen := -1;
  186.         IDCMPFlags := f_idcmp;
  187.         Flags := f_settings;
  188.         FirstGadget := nil;
  189.         CheckMark := nil;
  190.         if wtitle='' then
  191.             Title := nil
  192.         else
  193.         begin
  194.             wtitle := wtitle+#0;    { Make a null-terminated title }
  195.             Title := @wtitle[1]
  196.         end;
  197.         Screen := wscreen;
  198.         BitMap := nil;
  199.         MinWidth := wmin;
  200.         MinHeight := hmin;
  201.         MaxWidth := wmax;
  202.         MaxHeight := hmax;
  203.         if wmin or hmin or wmax or hmax>0 then    { Minimums and maximums? }
  204.             Flags := Flags or WINDOWSIZING;        { Must be resizeable }
  205.         if Screen=nil then
  206.             Type_ := WBENCHSCREEN
  207.         else
  208.             Type_ := CUSTOMSCREEN
  209.     end;
  210.     act_win := OpenWindow(@new_win);
  211.     if act_win<>nil then    { Opened okay? }
  212.     begin
  213.         inc(topBaseList);    { Add it to the list }
  214.         with BaseList[topBaseList] do
  215.         begin
  216.             kind := BASE_WINDOW;
  217.             pwin := act_win
  218.         end;
  219.         NewWindow := act_win
  220.     end
  221.     else
  222.         NewWindow := nil
  223. end;
  224. {----------------------------------------------------------}
  225. { Initialization section diverts the exit routine to CloseBase
  226.   upon exit and initializes the libraries that will be used
  227. }
  228.  
  229. begin
  230.     okBase := FALSE;    { Not everything is okay yet }
  231.     IntuitionBase := nil;    { Hasn't been opened yet, set to NIL }
  232.     GfxBase := nil;            { Same here }
  233.     topBaseList := 0;        { Nothing in the auto. list }
  234.     ExitSave := ExitProc;    { Store the current exit procedure }
  235.     ExitProc := @CloseBase; { Add CloseBase to exit chain }
  236.     IntuitionBase := pIntuitionBase(OpenLibrary('intuition.library',0));
  237.     if IntuitionBase<>nil then
  238.     begin
  239.         GfxBase := pGfxBase(OpenLibrary('graphics.library',0));
  240.         if GfxBase<>nil then
  241.             okBase := TRUE
  242.     end
  243. end.